;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2020, 2021, 2022 GNUnet e.V.
;;
;;   scheme-GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   scheme-GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; Author: Maxime Devos
;; Source: gnu/gnunet/utils/bv-slice.scm
;; Brief: parts of bytevectors, with read/write restricted
;; (TODO: parts of vectors, uniform vectors ...)

(library (gnu gnunet utils bv-slice)
  (export slice?
	  ;; Slicing
	  slice-bv
	  slice-offset
	  slice-length
	  slice-slice
	  bv-slice/read-write
	  make-slice/read-write
	  slice-readable?
	  slice-writable?
	  slice/read-only
	  slice/write-only
	  slice/read-write
	  verify-slice-readable
	  verify-slice-writable
	  ;; Small operations
	  slice-u8-ref
	  slice-u16-ref
	  slice-u32-ref
	  slice-u64-ref
	  slice-u8-set!
	  slice-u16-set!
	  slice-u32-set!
	  slice-u64-set!
	  slice-s8-ref
	  slice-s16-ref
	  slice-s32-ref
	  slice-s64-ref
	  slice-s8-set!
	  slice-s16-set!
	  slice-s32-set!
	  slice-s64-set!
	  slice-ieee-double-ref
	  slice-ieee-double-set!
	  ;; Large operations
	  slice-copy!
	  slice-zero!
	  slice-copy/read-write
	  slice-copy/read-only

	  ;; Exceptions
	  &missing-capabilities
	  make-missing-capabilities
	  missing-capabilities?
	  missing-capabilities-what
	  missing-capabilities-permitted
	  missing-capabilities-required
	  CAP_READ CAP_WRITE

	  slice-independent?)
  (import (rnrs arithmetic bitwise)
	  (rnrs base)
	  (rnrs bytevectors)
	  (rnrs control)
	  (rnrs conditions)
	  (rnrs exceptions)
	  (rnrs records syntactic)
	  (srfi srfi-31)
	  ;; only for printing records
	  (only (rnrs io ports)
		put-char put-string)
	  (only (srfi srfi-9 gnu)
		set-record-type-printer!))
  
  ;; Exceptions
  (define-condition-type &missing-capabilities &error
    %make-missing-capabilities missing-capabilities?
    ;; For disambiguation (source, target, from, to, ...)
    (what missing-capabilities-what)
    ;; Union of CAP_READ, CAP_WRITE, ...
    (permitted missing-capabilities-permitted)
    ;; Union of CAP_READ, CAP_WRITE, ...
    (required  missing-capabilities-required))

  (define (make-missing-capabilities what permitted required)
    "Make a &missing-capabilities condition.  @var{what} is a symbolic
name for the slice, @var{permitted} the capabilities of the slice and
@var{required} the capabilities that were needed."
    ;; TODO: should ~(required <= permitted) be enforced?
    (assert (and (integer? permitted) (exact? permitted)
		 (<= 0 permitted) (< permitted CAP_ALL)
		 (integer? required) (exact? required)
		 (<= 0 required) (< required CAP_ALL)))
    (%make-missing-capabilities what permitted required))

  
  ;; Slicing

  (define-record-type (<slice> %make-slice slice?)
    ;; TODO: perhaps use pointer->bytevector
    ;; and bytevector->pointer when available
    ;; to remove the use of offset and length
    (fields (immutable bv slice-bv) ;; unsafe: bounds may be ignored
	    (immutable offset slice-offset) ;; unsafe: implementation details
	    (immutable length slice-length)
	    (immutable cap-bits slice-capability-bits))
    (opaque #t)
    (sealed #t))

  ;; Not set in stone.  Override the record printer to
  ;; avoid printing large bytevectors and instead only
  ;; print the sliced part.
  (define (print-slice slice port)
    (put-string port "#<slice (")
    (put-string port
		(cond ((and (slice-readable? slice)
			    (slice-writable? slice))
		       "CAP_READ | CAP_WRITE")
		      ((slice-readable? slice)
		       "CAP_READ")
		      ((slice-writable? slice)
		       "CAP_WRITE")
		      ;; Currently not constructible.
		      (#t
		       "0")))
    ;; When the slice is readable, print the bytes in the slice.
    (cond ((slice-readable? slice)
	   (put-string port "):")
	   (let ((bv (slice-bv slice))
		 (end (+ (slice-offset slice)
			 (slice-length slice))))
	     (let loop ((i (slice-offset slice)))
	       (if (< i end)
		   (let ((val (bytevector-u8-ref bv i)))
		     (put-char port #\ )
		     (put-string port (number->string val))
		     (loop (+ i 1)))))))
	  (#true
	   ;; While the bytes in the slice cannot be printer because
	   ;; the slice is not readable, the length of the slice can
	   ;; still be printed.
	   (put-string port ") length: ")
	   (put-string port (number->string (slice-length slice)))))
    (put-char port #\>))
  (set-record-type-printer! <slice> print-slice)

  (define slice-slice
    (case-lambda
      "Select a part of the slice, preserving capabilities"
      ((slice)
       (assert (slice? slice))
       slice)
      ((slice offset)
       (assert (slice? slice))
       (assert (and (integer? offset)
		    (exact? offset)
		    (<= 0 offset)
		    (<= offset (slice-length slice))))
       (%make-slice (slice-bv slice)
		    (+ offset (slice-offset slice))
		    (- (slice-length slice) offset)
		    (slice-capability-bits slice)))
      ((slice offset length)
       (assert (slice? slice))
       (assert (and (integer? offset)
		    (exact? offset)
		    (<= 0 offset)))
       (assert (and (integer? length)
		    (exact? length)
		    (<= 0 length)))
       (assert (<= (+ offset length)
		   (slice-length slice)))
       (%make-slice (slice-bv slice)
		    (+ offset (slice-offset slice))
		    length
		    (slice-capability-bits slice)))))

  (define CAP_READ  #b1)
  (define CAP_WRITE #b10)
  (define CAP_ALL (bitwise-ior CAP_READ CAP_WRITE))

  (define (slice-as-well process-first-arg)
    (case-lambda
      "Do @var{process-first-arg}, and then perhaps slice"
      ((obj)
       (process-first-arg obj))
      ((obj offset)
       (slice-slice (process-first-arg obj) offset))
      ((obj offset length)
       (slice-slice (process-first-arg obj) offset length))))

  (define bv-slice/read-write
    (slice-as-well
     (lambda (bv)
      "Construct a read-write bytevector slice.  Mutations will change
the bytevector in place."
      (assert (bytevector? bv))
      (%make-slice bv 0 (bytevector-length bv)
		   (bitwise-ior CAP_READ CAP_WRITE)))))

  (define (make-slice/read-write length)
    "Make a fresh, zero-initialised, read-write slice"
    (bv-slice/read-write (make-bytevector length 0)))

  (define (make-slice-cap-p required-cap-bits)
    (assert (= (bitwise-and required-cap-bits CAP_ALL)
	       required-cap-bits))
    (lambda (slice)
      "Does @var{slice} have the capabilities @var{required-cap-bits}?"
      (= (bitwise-and (slice-capability-bits slice) required-cap-bits)
	 required-cap-bits)))

  (define (verify-slice-cap what slice required-cap-bits)
    "Verify that @var{slice} has the capabilities @var{required-cap-bits}.
If not, raise an appropriate @code{&missing-capabilities}."
    (unless ((make-slice-cap-p required-cap-bits) slice)
      (let ((permitted-cap-bits (slice-capability-bits slice)))
	(raise (make-missing-capabilities what permitted-cap-bits
					  required-cap-bits)))))
  (define (make-verify-slice-cap required-cap-bits)
    (lambda (what slice)
      "Verify that @var{slice} has the capabilities @var{required-cap-bits}.
If not, raise an appropriate @code{&missing-capabilities}."
      (verify-slice-cap what slice required-cap-bits)))

  (define slice-readable? (make-slice-cap-p CAP_READ))
  (define slice-writable? (make-slice-cap-p CAP_WRITE))
  (define verify-slice-readable (make-verify-slice-cap CAP_READ))
  (define verify-slice-writable (make-verify-slice-cap CAP_WRITE))

  (define (make-select-capabilities desired-cap-bits)
    (slice-as-well
     (lambda (slice)
       (verify-slice-cap 'slice slice desired-cap-bits)
       (%make-slice (slice-bv slice)
		    (slice-offset slice)
		    (slice-length slice)
		    desired-cap-bits))))
  (define slice/read-only
    (make-select-capabilities CAP_READ))
  (define slice/write-only
    (make-select-capabilities CAP_WRITE))
  (define slice/read-write
    (make-select-capabilities (bitwise-ior CAP_READ CAP_WRITE)))

  
  ;; ‘Small’ operations

  (define (wrap-rnrs-ref rnrs-ref verify size)
    (lambda (slice index . rest)
      (assert (and (exact? index)
		   (integer? index)
		   (<= 0 index)
		   (<= (+ index size) (slice-length slice))))
      (verify 'slice slice)
      (apply rnrs-ref (slice-bv slice)
	     (+ (slice-offset slice) index)
	     rest)))

  (define slice-u8-ref
    (wrap-rnrs-ref bytevector-u8-ref verify-slice-readable 1))
  (define slice-u16-ref
    (wrap-rnrs-ref bytevector-u16-ref verify-slice-readable 2))
  (define slice-u32-ref
    (wrap-rnrs-ref bytevector-u32-ref verify-slice-readable 4))
  (define slice-u64-ref
    (wrap-rnrs-ref bytevector-u64-ref verify-slice-readable 8))

  (define slice-s8-ref
    (wrap-rnrs-ref bytevector-s8-ref verify-slice-readable 1))
  (define slice-s16-ref
    (wrap-rnrs-ref bytevector-s16-ref verify-slice-readable 2))
  (define slice-s32-ref
    (wrap-rnrs-ref bytevector-s32-ref verify-slice-readable 4))
  (define slice-s64-ref
    (wrap-rnrs-ref bytevector-s64-ref verify-slice-readable 8))

  (define slice-u8-set!
    (wrap-rnrs-ref bytevector-u8-set! verify-slice-writable 1))
  (define slice-u16-set!
    (wrap-rnrs-ref bytevector-u16-set! verify-slice-writable 2))
  (define slice-u32-set!
    (wrap-rnrs-ref bytevector-u32-set! verify-slice-writable 4))
  (define slice-u64-set!
    (wrap-rnrs-ref bytevector-u64-set! verify-slice-writable 8))

  (define slice-s8-set!
    (wrap-rnrs-ref bytevector-s8-set! verify-slice-writable 1))
  (define slice-s16-set!
    (wrap-rnrs-ref bytevector-s16-set! verify-slice-writable 2))
  (define slice-s32-set!
    (wrap-rnrs-ref bytevector-s32-set! verify-slice-writable 4))
  (define slice-s64-set!
    (wrap-rnrs-ref bytevector-s64-set! verify-slice-writable 8))

  (define slice-ieee-double-ref
    (wrap-rnrs-ref bytevector-ieee-double-ref verify-slice-readable 8))
  (define slice-ieee-double-set!
    (wrap-rnrs-ref bytevector-ieee-double-set! verify-slice-writable 8))

  
  ;; ‘Large’ operations.

  (define (slice-zero! slice)
    "Zero out the writable slice @var{slice}."
    (verify-slice-writable 'slice slice)
    ;; TODO optimise this and/or optimise guile's compiler
    ;; w.r.t. bytevectors, structs and type inference.
    (let loop ((i 0))
      (when (< i (slice-length slice))
	(slice-u8-set! slice i 0)
	(loop (+ i 1))))
    (values))

  (define (slice-copy! from to)
    "Copy the contents of the readable slice @var{from} to
the writable slice @var{slice}.  The slices may overlap."
    (verify-slice-readable 'from from)
    (verify-slice-writable 'to to)
    (assert (= (slice-length from) (slice-length to)))
    (bytevector-copy! (slice-bv from) (slice-offset from)
		      (slice-bv to) (slice-offset to)
		      (slice-length from))
    (values))

  (define (slice-copy/read-write original)
    "Return a fresh read-write slice with the same contents as @var{original}.
Future modifications to @var{original} will not impact the returned slice.
The slice @var{original} must be readable."
    (verify-slice-readable 'original original)
    (define new (make-slice/read-write (slice-length original)))
    (slice-copy! original new)
    new)

  (define (slice-copy/read-only original)
    "Return a fresh read-only slice with the same contents as @var{original}.
Future modifications to @var{original} will not impact the returned slice.
THe slice @var{originall} must be readable."
    (slice/read-only (slice-copy/read-write original)))

  (define (slice-independent? x y)
    "Return @code{#true} if all changes to the bytes in @var{x} do not
impact @var{y}, @code{#false} otherwise.  This is a symmetric relation.
If @var{x} or @var{y} is empty, the slices @var{x} and @var{y} are independent.
The capabilities of @var{x} and @var{y} are irrelevant."
    ;; Except for utils/bv-slice.scm, the tests actually only require
    ;; @code{(not (eq? (slice-bv x) (slice-bv y)))}.
    ;;
    ;; TODO: should write access to 'x' or 'y' be required?
    (or (not (eq? (slice-bv x) (slice-bv y)))
	(= 0 (slice-length x))
	(= 0 (slice-length y))
	(<= (+ (slice-offset x) (slice-length x)) (slice-offset y))
	(<= (+ (slice-offset y) (slice-length y)) (slice-offset x)))))
